{*
  Object Pascal simple file manipulation routines
  @Author  Maciej Zagozda (1998-2009)
  @Licence Microsoft Reciprocal License (Ms-RL)
  @Website http://www.codeplex.com/intelitechdelphirtns/
  @Version 2008/04/20 Added documentation support
}

{$DEFINE UseFileFind}

{$IFDEF VER110}
  {$DEFINE BorlandDelphi3}
{$ENDIF}

{$IFDEF VER120}
  {$DEFINE BorlandDelphi4}
{$ENDIF}

{$IFDEF VER130}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
{$ENDIF}

{$IFDEF VER140}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
{$ENDIF}

{$IFDEF VER150}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
  {$DEFINE BorlandDelphi7}
{$ENDIF}

{$IFDEF VER160}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
  {$DEFINE BorlandDelphi7}
  {$DEFINE BorlandDelphi8}
{$ENDIF}

{$IFDEF VER170}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
  {$DEFINE BorlandDelphi7}
  {$DEFINE BorlandDelphi8}
  {$DEFINE BorlandDelphi2005}
{$ENDIF}

{$IFDEF VER180}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
  {$DEFINE BorlandDelphi7}
  {$DEFINE BorlandDelphi8}
  {$DEFINE BorlandDelphi2005}
  {$DEFINE BorlandDelphi2006}
{$ENDIF}

{$IFDEF VER190}
  {$DEFINE BorlandDelphi3}
  {$DEFINE BorlandDelphi4}
  {$DEFINE BorlandDelphi5}
  {$DEFINE BorlandDelphi6}
  {$DEFINE BorlandDelphi7}
  {$DEFINE BorlandDelphi8}
  {$DEFINE BorlandDelphi2005}
  {$DEFINE BorlandDelphi2006}
  {$DEFINE BorlandDelphi2007}
{$ENDIF}

unit FileRoutines;

interface

uses
  Classes,
  Comctrls,
  Dialogs,
  {$IFDEF UseFileFind} FileFind, {$ENDIF}
  Forms,
  LZExpand,
  Messages,
  Windows,
  WinTypes,
  ShellApi,
  SysUtils;

function CreateFileEx( strnFileName: AnsiString; boolFailIfExists: Boolean ): Boolean;
function CopyFile( strnSourceFileName: AnsiString; strnDestinationFileName: AnsiString ): Boolean;
function CopyFile2( strnS, strnD: AnsiString; prgDefault: TProgressBar ): Boolean;
{$IFDEF UseFileFind} function DeleteFiles( strnFolderName: AnsiString; strnFileMask: AnsiString; boolRecurse: Boolean ): Boolean; {$ENDIF}
function ExpandFile( strnSourceFileName: AnsiString; strnDestinationFileName: AnsiString ): Boolean;
function GetFileDate( strnFileName: AnsiString ): TDateTime;
function GetFileInUse(strFileName: AnsiString): Boolean;
function GetFileLastAccessTime( strnFileName : AnsiString ): TDateTime;
function GetSizeFile( const strnFileName: AnsiString ): Longint;
function GetUserFile( strnCompany, strnProduct, strnFileName: AnsiString ): AnsiString;
function PackFiles( strlFiles: TStrings; const strnFilename: AnsiString ): Boolean;
function ProbeFile( strnFileName: AnsiString; boolFailIfExists: Boolean ): Boolean;
function RemoveFile(const strFileName: AnsiString): Boolean;
function SetFileDateTime( strnFileName: AnsiString; dateDateTime: TDateTime): Boolean;
function TrimFileExtension( strnFileName: AnsiString ): AnsiString;
function TrimFileName( strnFileName: AnsiString ): AnsiString;
function UnpackFiles( const strnFilename, strnDirectory : AnsiString): Boolean;
function WindowsCopyAllFiles(sFrom, sTo: AnsiString; Protect: Boolean): Boolean;
function WindowsDeleteAllFiles(FilesOrDir: AnsiString): Boolean;

procedure RunAsAdmin( hWnd: HWND; aFile: AnsiString; aParameters: AnsiString );

implementation

uses
  DateRoutines,
  FolderRoutines,
  StringRoutines,

  Zlib;

function CreateFileEx( strnFileName: AnsiString; boolFailIfExists: Boolean ): Boolean;
var
  fileFileName: TextFile;
begin
  if ( FileExists( strnFileName )) and ( boolFailIfExists ) then
  begin
    Result := False;
    Exit;
  end;//if

  try
    AssignFile( fileFileName, strnFileName );
    Rewrite( fileFileName );
    CloseFile( fileFileName )
  except
    Result := False;
    Exit;
  end;//try

  Result := True;
end;

//_____________________________________________________________________________

function CopyFile( strnSourceFileName: AnsiString; strnDestinationFileName: AnsiString ): Boolean;
var
  fileSource: file;
  fileDestination: file;
  wordRead: Integer;
  wordWritten: Integer;
  Buffer: array[0..2048] of Char;
begin
  try
    AssignFile( fileSource, strnSourceFileName );
    Reset( fileSource, 1 );

    AssignFile( fileDestination, strnDestinationFileName );
    Rewrite( fileDestination, 1 );

    repeat
      BlockRead( fileSource, Buffer, SizeOf( Buffer ), wordRead );
      BlockWrite( fileDestination, wordRead, SizeOf( Buffer), wordWritten );
    until ( wordRead = 0) or ( wordRead <> wordWritten );

    CloseFile( fileSource );
    CloseFile( fileDestination );

    Result := True;

  except
    Result := False;
    Exit;
  end;//except
end;

//_____________________________________________________________________________

function CopyFile2( strnS, strnD: AnsiString; prgDefault: TProgressBar ): Boolean;
var
  FromF, ToF: file of byte;
  Buffer: array[0..4096] of char;
  NumRead: integer;
  FileLength: longint;
begin

  Result := True;

  try
    AssignFile(FromF, strnS );
    reset(FromF);
    AssignFile(ToF, strnD);
    rewrite(ToF);

    FileLength := FileSize(FromF);
    with prgDefault do
    begin
      Min := 0;
      Max := FileLength;
      while FileLength > 0 do
      begin
        BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
        FileLength := FileLength - NumRead;
        BlockWrite(ToF, Buffer[0], NumRead);
        Position := Position + NumRead;
      end;
      CloseFile(FromF);
      CloseFile(ToF);
    end;
  except
    Result := False;
  end;//try
end;

 {$IFDEF UseFileFind}

function DeleteFiles( strnFolderName: AnsiString; strnFileMask: AnsiString; boolRecurse: Boolean ): Boolean;
var
  ffndA: TFileFind;
  intgA: Integer;
  boolA: Boolean;
begin

  boolA := True;
  ffndA := TFileFind.Create( nil );

  try
    with ffndA do
    begin
      Recurse := boolRecurse;
      Directory := strnFolderName;
      Filter := strnFileMask;
      Execute;

      for intgA := 0 to Files.Count -1 do
      begin
        boolA := boolA and DeleteFile( Files[intgA] );
      end;//for
    end;//with
  finally
    ffndA.Free;
  end;//try

  Result := boolA;

end;

{$ENDIF}
//_____________________________________________________________________________

function ExpandFile( strnSourceFileName: String; strnDestinationFileName: String): Boolean;
var
  charSourceFileName: Array[0..255] Of Char;
  charDestinationFileName: Array[0..255] Of Char;
  OpenBuf: TOFStruct;
  HandleSrc, HandleDst: Integer;
begin
  StrPCopy( charSourceFileName, strnSourceFileName );
  StrPCopy( charDestinationFileName, strnDestinationFileName );

  HandleSrc := LZOpenFile( charSourceFileName, OpenBuf, OF_READ );
  If HandleSrc = -1 Then
  begin
    Result := False;
    Exit;
  end;//if

  HandleDst := LZOpenFile( charDestinationFileName, OpenBuf, OF_WRITE or OF_CREATE );
  If HandleDst = -1 Then
  begin
    Result := False;
    Exit;
  end;//if

  If LZCopy (HandleSrc, HandleDst) <= 0 Then
  begin
    Result := False;
    Exit;
  end;//if

  LZClose( HandleSrc );
  LZClose( HandleDst );
  Result := True;
end;

function GetFileInUse(strFileName : AnsiString): Boolean;
var
  HFileRes : HFILE;
  Res: string[6];

  function CheckAttributes(FileNam: string; CheckAttr: string): Boolean;
  var
    fa: Integer;
  begin
    fa := GetFileAttributes(PChar(FileNam)) ;
    Res := '';

    if (fa and FILE_ATTRIBUTE_NORMAL) <> 0 then
    begin
      Result := False;
      Exit;
    end;

    if (fa and FILE_ATTRIBUTE_ARCHIVE) <> 0 then Res := Res + 'A';
    if (fa and FILE_ATTRIBUTE_COMPRESSED) <> 0 then Res := Res + 'C';
    if (fa and FILE_ATTRIBUTE_DIRECTORY) <> 0 then Res := Res + 'D';
    if (fa and FILE_ATTRIBUTE_HIDDEN) <> 0 then Res := Res + 'H';
    if (fa and FILE_ATTRIBUTE_READONLY) <> 0 then Res := Res + 'R';
    if (fa and FILE_ATTRIBUTE_SYSTEM) <> 0 then Res := Res + 'S';

    Result := AnsiPos(CheckAttr,Res) >0;
  end;

  procedure SetAttr(strFileName: string) ;
  var
    Attr: Integer;
  begin
    Attr := 0;
    if AnsiPos('A',Res) >0 then Attr := Attr + FILE_ATTRIBUTE_ARCHIVE;
    if AnsiPos('C',Res) >0 then Attr := Attr + FILE_ATTRIBUTE_COMPRESSED;
    if AnsiPos('D',Res) >0 then Attr := Attr + FILE_ATTRIBUTE_DIRECTORY;
    if AnsiPos('H',Res) >0 then Attr := Attr + FILE_ATTRIBUTE_HIDDEN;
    if AnsiPos('S',Res) >0 then Attr := Attr + FILE_ATTRIBUTE_SYSTEM;

    SetFileAttributes(PChar(strFileName), Attr) ;
  end;
begin

  if CheckAttributes(strFileName, 'R') then
  begin
    Result := False;

    if not FileExists(strFileName) then exit;

    {
    if MessageDlg(ExtractFileName(strFileName) + ' is a READ-ONLY file.' + #13#10 + 'Do you wish to clear the READ-ONLY flag???', mtConfirmation, [mbYes, mbNo], 0) = mrNo then
    beginb
      Result := True;
      Exit;
    end;
    }
  end;

  SetFileAttributes(PChar(strFileName), FILE_ATTRIBUTE_NORMAL) ;

  SetAttr(strFileName) ;


  HFileRes := CreateFile( pchar(strFileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) ;
  Result := (HFileRes = INVALID_HANDLE_VALUE) ;
  if not Result then CloseHandle(HFileRes) ;

end; 

//_____________________________________________________________________________

function GetFileLastAccessTime( strnFileName : AnsiString ): TDateTime;
var
  hndlHandle: THandle;
  fdtdFindData: TWin32FindData;
  fltmFileTime: TFileTime;
  dwrdA: DWord;
begin
  hndlHandle := Windows.FindFirstFile( PChar( strnFileName ), fdtdFindData );
  if( INVALID_HANDLE_VALUE <> hndlHandle ) then
  begin
    Windows.FindClose( hndlHandle );
    FileTimeToLocalFileTime( fdtdFindData.ftLastAccessTime, fltmFileTime );
    FileTimeToDosDateTime( fltmFileTime, LongRec( dwrdA ).Hi, LongRec( dwrdA ).Lo );
    Result := FileDateToDateTime( dwrdA );
  end
  else
  begin
    Result := -1;
  end;//if
end;

//_____________________________________________________________________________

function GetSizeFile(const strnFileName: AnsiString): Longint;
var
  SearchRec: TSearchRec;
begin

  if FindFirst(strnFileName, faAnyFile, SearchRec) = 0 then
  begin
    Result := SearchRec.Size;
    SysUtils.FindClose(SearchRec);
  end
  else
  begin
    Result := -1;
  end;

end;

//_____________________________________________________________________________

function GetFileDate( strnFileName: String ): TDateTime;
begin
  try
    Result := FileDateToDateTime( FileAge( strnFileName ));
  except
    Result := -1;
  end;//try
end;

//_____________________________________________________________________________

function GetUserFile( strnCompany, strnProduct, strnFileName: AnsiString ): AnsiString;
var
  strnLocalFolder, strnTargetFolder, strnTargetFile: AnsiString;
  boolE: Boolean;
begin

  strnTargetFile := '';
  strnLocalFolder := GetProgramFolder;

  if AnsiPos( 'PROGRAM FILES', AnsiUpperCase( strnLocalFolder )) > 0 then
  begin

    // aplikacja moze zapisywac w katalogu uzytkownika
    // poniewaz zapisywanie w program files juz nie jest dozwolone w Windows Vista

    strnTargetFolder := AppendBackslash( GetLocalAppDataFolder ) + AppendBackslash( strnCompany ) + AppendBackslash( strnProduct );

    if FolderExists( strnTargetFolder ) then
    begin
      boolE := True;
    end
    else
    begin
      boolE := CreateFolder( strnTargetFolder );
    end;//if

    if boolE then
    begin
      strnTargetFile := AppendBackslash( strnTargetFolder ) + strnFileName;
    end
    else
    begin
      strnTargetFile := AppendBackslash( GetProgramFolder ) + strnFileName;
    end;//if

  end
  else
  begin

    // aplikacja moze zapisywac w katalogu, z ktorego zostala uruchomiona
    // np. w przypadku uruchamiania z dyskow podlaczonych przez USB

    strnTargetFile := AppendBackslash( GetProgramFolder ) + strnFileName;
  end;//if

  Result := strnTargetFile;

end;

//_____________________________________________________________________________

function PackFiles( strlFiles: TStrings; const strnFilename: AnsiString ): Boolean;
var
  infile, outfile, tmpFile : TFileStream;
  compr : TCompressionStream;
  i,l : Integer;
  s : String;

  boolResult: Boolean;

begin

  boolResult := False;

  if strlFiles.Count > 0 then
  begin
    outFile := TFileStream.Create( strnFilename, fmCreate );
    try
      { the number of files }
      l := strlFiles.Count;
      outfile.Write(l,SizeOf(l));
      for i := 0 to strlFiles.Count-1 do
      begin
        infile := TFileStream.Create( strlFiles[i], fmOpenRead );
        try
          { the original filename }
          s := ExtractFilename( strlFiles[i] );
          l := Length(s);
          outfile.Write(l,SizeOf(l));
          outfile.Write(s[1],l);
          { the original filesize }
          l := infile.Size;
          outfile.Write(l,SizeOf(l));
          { compress and store the file temporary}
          tmpFile := TFileStream.Create('tmp',fmCreate);
          compr := TCompressionStream.Create(clMax,tmpfile);
          try
            compr.CopyFrom(infile,l);
          finally
            compr.Free;
            tmpFile.Free;
          end;
          { append the compressed file to the destination file }
          tmpFile := TFileStream.Create('tmp',fmOpenRead);
          try
            outfile.CopyFrom(tmpFile,0);
          finally
            tmpFile.Free;
          end;
        finally
          infile.Free;
        end;
      end;
    finally
      outfile.Free;
    end;
    DeleteFile('tmp');
  end;

  boolResult := True;
  Result := boolResult;
end;

//_____________________________________________________________________________

function ProbeFile( strnFileName: AnsiString; boolFailIfExists: Boolean ): Boolean;
begin
  if ( CreateFileEx( strnFileName, boolFailIfExists )) and
     ( DeleteFile ( strnFileName )) then
  begin
    Result := True;
  end
  else
  begin
    Result := False;
  end;//if
end;

{*
  Removes a file using Windows recycle bin instead of deleting using SysUtils
  @param strFileName: fully qualified file name of file to be deleted
  @return True on successful deletion, False otherwise
*}

function RemoveFile(const strFileName: AnsiString): Boolean;
var
  shfDefault: TSHFileOpStruct;
begin
  with shfDefault do
  begin
    Wnd := Application.Handle;
    wFunc := FO_DELETE;
    pFrom := PChar(strFileName);
    fFlags := FOF_SILENT or FOF_ALLOWUNDO;
  end;

  try
    SHFileOperation(shfDefault);
    Result := True;
  except
    Result := False;
  end;//try
end;

//_____________________________________________________________________________

function SetFileDateTime( strnFileName: AnsiString; dateDateTime: TDateTime): Boolean;
var
  FileHandle: Integer;
  FileTime: TFileTime;
  LFT: TFileTime;
  LST: TSystemTime;
begin
  Result := False;
  try
    DecodeDate( dateDateTime, LST.wYear, LST.wMonth, LST.wDay );
    DecodeTime( dateDateTime, LST.wHour, LST.wMinute, LST.wSecond, LST.wMilliSeconds );
    if SystemTimeToFileTime( LST, LFT ) then
    begin
      if LocalFileTimeToFileTime( LFT, FileTime ) then
      begin
        FileHandle := FileOpen( strnFileName, fmOpenReadWrite or fmShareExclusive );
        if SetFileTime(FileHandle, nil, nil, @FileTime) then Result := True;
        FileClose(FileHandle);
        Result := True;
      end;//if
    end;
  except
    Result := False;
  end;
end;

//_____________________________________________________________________________

function TrimFileExtension( strnFileName: AnsiString ): AnsiString;
begin
  if Pos( '.', strnFileName ) > 0 then
  begin 
    strnFileName := Copy( strnFileName, 1, Pos( '.', strnFileName ) - 1 );
  end;//if

  Result := strnFileName;
end;

//_____________________________________________________________________________

function TrimFileName( strnFileName: AnsiString ): AnsiString;
var
  intgA: Integer;
  strnResult: AnsiString;

begin
  for intgA := 1 to Length( strnFileName ) do
  begin
    if ( strnFileName[intgA] <> '.' ) and
       ( strnFileName[intgA] <> ',' ) and
       ( strnFileName[intgA] <> '?' ) and
       ( strnFileName[intgA] <> '/' ) and
       ( strnFileName[intgA] <> '\' ) and
       ( strnFileName[intgA] <> ':' ) and
       ( strnFileName[intgA] <> '*' ) and
       ( strnFileName[intgA] <> '"' ) and
       ( strnFileName[intgA] <> '(' ) and
       ( strnFileName[intgA] <> ')' ) and
       ( strnFileName[intgA] <> '<' ) and
       ( strnFileName[intgA] <> '>' ) and
       ( strnFileName[intgA] <> '|' ) then
    begin
      strnResult := strnResult + strnFileName[intgA];
    end;//if
  end;//for

  Result := Trim( Copy( strnResult, 1, 31 ));
end;

//_____________________________________________________________________________

function UnpackFiles( const strnFilename, strnDirectory: AnsiString): Boolean;
var
  dest,s : String;
  decompr : TDecompressionStream;
  infile, outfile : TFilestream;
  i,l,c : Integer;

  boolResult: Boolean;
begin

  // IncludeTrailingPathDelimiter (D6/D7 only)
  //dest := IncludeTrailingPathDelimiter(DestDirectory);

  Dest := AppendBackslash( strnDirectory );

  infile := TFileStream.Create( strnFilename, fmOpenRead );
  try
    { number of files }
    infile.Read(c,SizeOf(c));
    for i := 1 to c do
    begin
      { read filename }
      infile.Read(l,SizeOf(l));
      SetLength(s,l);
      infile.Read(s[1],l);
      { read filesize }
      infile.Read(l,SizeOf(l));
      { decompress the files and store it }
      s := dest+s; //include the path
      outfile := TFileStream.Create(s,fmCreate);
      decompr := TDecompressionStream.Create(infile);
      try
        outfile.CopyFrom(decompr,l);
      finally
        outfile.Free;
        decompr.Free;
      end;
    end;
  finally
    infile.Free;
  end;

  boolResult := True;
  Result := boolResult;
end;

{ Copies files or directory to another directory. }

function WindowsCopyAllFiles(sFrom, sTo: AnsiString; Protect: Boolean): Boolean;
var
  F: TShFileOpStruct;
  ResultVal: integer;
  tmp1, tmp2: string;
begin
  FillChar(F, SizeOf(F), #0);
  try
    F.Wnd := 0;
    F.wFunc := FO_COPY;
    { Add an extra null char }
    tmp1 := sFrom + #0;
    tmp2 := sTo + #0;
    F.pFrom := PChar(tmp1);
    F.pTo := PChar(tmp2);
    if Protect then
    begin
      F.fFlags := FOF_RENAMEONCOLLISION or FOF_SIMPLEPROGRESS
    end
    else
    begin
      F.fFlags := FOF_SIMPLEPROGRESS;
    end;//if
    F.fAnyOperationsAborted := False;
    F.hNameMappings := nil;
    Resultval := ShFileOperation(F);
    Result := (ResultVal = 0);
  finally
  end;
end;

// Sends files or directory to the recycle bin

function WindowsDeleteAllFiles(FilesOrDir: AnsiString): Boolean;
var
  F: TSHFileOpStruct;
  From: string;
  Resultval: integer;
begin
  FillChar(F, SizeOf(F), #0);
  From := FilesOrDir + #0;
  try
    F.wnd := 0;
    F.wFunc := FO_DELETE;
    F.pFrom := PChar(From);
    F.pTo := nil;
    F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SIMPLEPROGRESS or FOF_FILESONLY;
    F.fAnyOperationsAborted := False;
    F.hNameMappings := nil;
    Resultval := ShFileOperation(F);
    Result := (ResultVal = 0);
  finally
  end; 
end;

// starts the process with administrator privileges under Windows Vista

procedure RunAsAdmin( hWnd: HWND; aFile: AnsiString; aParameters: AnsiString );
var
  sei: TShellExecuteInfoA;
begin
  FillChar( sei, SizeOf(sei), 0 );
  sei.cbSize := sizeof(sei);
  sei.WND := hwnd;
  sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
  sei.lpVerb := 'runas';
  sei.lpFile := PChar( aFile );
  sei.lpParameters := PChar( aParameters );
  sei.nShow := SW_SHOWNORMAL;
  if not ShellExecuteEx(@sei) then
  begin
    //RaiseLastOSError;
  end;//if
end;

end.



